home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / Widget / Wplot.stk < prev    next >
Encoding:
Text File  |  1995-12-21  |  2.7 KB  |  82 lines
  1. ;;;;
  2. ;;;; STk adaptation of the Tk widget demo.
  3. ;;;;
  4. ;;;; This demonstration script creates a canvas widget showing a 2-D
  5. ;;;; plot with data points that can be dragged with the mouse.
  6. ;;;;
  7.  
  8. ;; demo-plot can be used also by the text embedded windows demos. In this case,
  9. ;; it is called with an argument which its embedding window
  10.  
  11. (define (demo-plot . arg)
  12.   (let* ((w          (if (null? arg)
  13.              (make-demo-toplevel  "plot"
  14.                           "Plot Demonstration"
  15.                           "This window displays a canvas widget containing a simple 2-dimensional plot.  You can doctor the data by dragging any of the points with mouse button 1.")
  16.              (car arg)))
  17.      (c          (make <Canvas> :parent w :width 450 :height 300
  18.                        :cursor "top_left_arrow"))
  19.      (plot-font  "-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*")
  20.      (last-x     0)
  21.      (last-y     0))
  22.  
  23.     (define (plot-down w x y)
  24.       (delete-tag w 'selected)
  25.       (add-tag w 'selected 'withtag 'current)
  26.       (raise c 'current)
  27.       (set! last-x x)
  28.       (set! last-y y))
  29.     
  30.     (define (plot-move w x y)
  31.       (move c 'selected (- x last-x) (- y last-y))
  32.       (set! last-x x)
  33.       (set! last-y y))
  34.     
  35.     (pack c :side "top" :fill "x")
  36.     
  37.     (make <Line>      :parent c :coords '(100 250 400 250) :width 2)
  38.     (make <Line>      :parent c :coords '(100 250 100 50)  :width 2)
  39.     (make <Text-item> :parent c :coords '(225 20) :text "A Simple Plot"
  40.                   :font plot-font :fill "brown")
  41.       
  42.     (dotimes (i 11)
  43.       (let ((x (+ 100 (* 30 i))))
  44.     (make <Line>         :parent c :coords (list x 250 x 245) :width 2)
  45.     (make <Text-item> :parent c :coords (list x 254) :anchor "n"
  46.                     :text (* 10 i) :font plot-font)))
  47.  
  48.     (dotimes (i 6)
  49.       (let ((y (- 250 (* 40 i))))
  50.     (make <Line>       :parent c :coords (list 100 y 105 y) :width 2)
  51.     (make <Text-item> :parent c :coords (list 96 y) :anchor "e"
  52.               :text (* 50 i) :font plot-font)))
  53.       
  54.     (for-each (lambda (point)
  55.         (let ((x (+ 100 (* 3 (car point))))
  56.               (y (- 250 (* 0.8 (cadr point)))))
  57.           (make <Oval> :parent  c 
  58.                    :coords  (list (- x 6) (- y 6) (+ x 6) (+ y 6))
  59.                    :width 1 
  60.                    :outline "black"
  61.                    :fill "SkyBlue2"
  62.                    :tags "point")))
  63.           '((12 56) (20 94) (33 98) (32 120) (61 180) (75 160) (98 223)))
  64.  
  65.  
  66.     (bind c "point" "<Any-Enter>" 
  67.       (lambda () 
  68.         (let ((i (car (find-items c 'withtag 'current))))
  69.           (set! (fill i) "red"))))
  70.  
  71.     (bind c "point" "<Any-Leave>" 
  72.       (lambda () 
  73.         (let ((i (car (find-items c 'withtag 'current))))
  74.           (set! (fill i) "SkyBlue2"))))
  75.       
  76.     (bind c "point" "<1>" (lambda (x y) (plot-down c x y)))
  77.     (bind c "point" "<ButtonRelease-1>" (lambda ()
  78.                       (delete-tag c 'selected)))
  79.  
  80.     (bind c "<B1-Motion>" (lambda (x y) (plot-move c x y)))
  81.     c))
  82.